home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / AddOns / eudbm.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-07-13  |  7.9 KB  |  349 lines
  1. /*
  2.   Project: Databases
  3.   File: eudbm.c
  4.   Date: 18/10/90
  5. */
  6.  
  7. /*
  8.   Database module for eulisp
  9.   Provides base-level routines
  10.   as per NDBM manual.
  11. */
  12.  
  13. #include <stdio.h>
  14. #include "defs.h"
  15. #include "structs.h"
  16. #include "funcalls.h"
  17. #include "global.h"
  18. #include "error.h"
  19. #include "allocate.h"
  20. #include "class.h"
  21. #include "modboot.h"
  22. #include "bootstrap.h"
  23. #include "allocate.h"
  24. #include "ngenerics.h"
  25.  
  26. #include "obread.h"
  27. #include "feel_malloc.h"
  28.  
  29. /* This may not be on some machines -- but gdbm sure is */
  30. #include "ndbm.h"
  31. #define dbm_hash _gdbm_hash
  32. #define MAXOBJLEN 16384
  33. #define EUDEBUG(x) x
  34. extern int errno;
  35.  
  36.  
  37. #include <fcntl.h>
  38.  
  39. #define ALLOCATE_PAIR(car,cdr)   EUCALL_2(Fn_cons,(car),(cdr))
  40. #define ARG_4(stack) (*(stack+4))
  41.  
  42. /* need to define new class --- dbm-file */
  43. /* We assume that keys are strings and 
  44.    records are numbers, symbols, strings, lists and vectors
  45.    Hopfully this is fairly general, and quite efficient.
  46. */
  47.  
  48. #define DBMOF(x)  *((DBM **)(stringof(x))) 
  49. #define SETDBMOF(x,y)  *((DBM**)(stringof(x)))=y;
  50.  
  51. /* an initarg or two*/
  52. static LispObject sym_name;
  53. static LispObject sym_mode;
  54. static LispObject sym_readonly;
  55. static LispObject sym_readwrite;
  56. static LispObject sym_create;
  57.  
  58. extern LispObject search_keylist(LispObject *,LispObject,LispObject);
  59.  
  60. EUFUN_1(Fn_open_dbase,lst)
  61. {
  62.   LispObject name,tmp;
  63.   int flags,create=FALSE;
  64.   DBM* dbase;
  65.   name=search_keylist(stacktop,lst,sym_name);
  66.   
  67.   if (name==nil)
  68.     CallError(stacktop,"Open dbase: No name supplied",nil,NONCONTINUABLE);
  69.   
  70.   if (is_symbol(name))
  71.     name=name->SYMBOL.pname;
  72.  
  73.   tmp=search_keylist(stacktop,lst,sym_mode);
  74.   
  75.   flags= (tmp==sym_readonly ? O_RDONLY 
  76.       : tmp==sym_readwrite ? O_RDWR : O_RDONLY);
  77.   if (search_keylist(stacktop,lst,sym_create)==lisptrue)
  78.     flags |= O_CREAT;
  79.   
  80.   fprintf(stderr,"Opening: %s %x",stringof(name),flags);
  81.   dbase=dbm_open(stringof(name),flags,0740);
  82.   
  83.   if (dbase==NULL)
  84.     {
  85.       perror("open");
  86.       CallError(stacktop,"Couldn't open dbase",name,NONCONTINUABLE);
  87.     }
  88.  
  89.   tmp=allocate_string(stacktop,"",sizeof(DBM*));
  90.   SETDBMOF(tmp,dbase);
  91.   return tmp;
  92. }
  93. EUFUN_CLOSE
  94.  
  95. /* 
  96.  * For extendability, if we don't have a database, we call these...
  97.  */
  98.  
  99. LispObject generic_dbase_fetch, generic_dbase_store;
  100.  
  101. EUFUN_3( Gf_generic_dbase_fetch,dbase, key,reader)
  102. {
  103.   return(generic_apply_3(stacktop,generic_dbase_fetch,dbase,key,reader));
  104. }
  105.  
  106. EUFUN_CLOSE
  107.  
  108. EUFUN_4( Gf_generic_dbase_store, dbase,
  109.                  key,
  110.                  value,
  111.                 reader)
  112. {
  113.   return(generic_apply_4(stacktop,generic_dbase_store,dbase,key,value,reader));
  114. }
  115. EUFUN_CLOSE
  116.  
  117. /* all objects stored as: type, value pairs
  118.    Note that a limit of 4K is imposed on the length of a record + key.
  119.    */
  120. EUFUN_3( Fn_dbase_fetch,dbase, key,reader_maybe)
  121. {
  122.   LispObject ret;
  123.   datum dkey;
  124.   datum result;
  125.   unsigned char *ptr; /* need a copy of the datapointer... */
  126.  
  127.   dbm_clearerr( DBMOF(dbase));
  128.   if (!is_string(key))
  129.     CallError(stacktop,"dbase_fetch: Key must be a string",key,NONCONTINUABLE);
  130.   
  131.   dkey.dptr = stringof(key);
  132.   dkey.dsize = strlen(stringof(key)) + 1;
  133.   
  134.   result = dbm_fetch( DBMOF(dbase), dkey);
  135.   
  136.   if (result.dptr == NULL)
  137.     {     
  138.       extern int gdbm_errno;
  139.  
  140.       fprintf(stderr,"dbm_fetch dbm_err: %d\n",gdbm_errno);
  141.       dbm_clearerr( DBMOF(dbase));
  142.       return nil;
  143.     } 
  144.  
  145.   /* It would be nice to allocate this locally */
  146.   ptr=(unsigned char *)result.dptr;
  147.   ret=read_obj(stacktop,&ptr,reader_maybe);
  148.   return ret;
  149. }
  150. EUFUN_CLOSE
  151.  
  152. EUFUN_4( Fn_dbase_store, dbase, key, record,reader)
  153. {
  154.   int dbase_store(DBM *, datum, datum, int);
  155.   datum dkey;
  156.   datum drecord;
  157.   static unsigned char *buf=NULL;
  158.   unsigned char *ptr;
  159.   int len=0;
  160.   
  161.   if (buf == NULL)
  162.     {
  163.       buf = (unsigned char *) feel_malloc(MAXOBJLEN);
  164.     }
  165.   dbm_clearerr(DBMOF( dbase));
  166.  
  167.   if (!is_string(key))
  168.     CallError(stacktop,"dbase_store: Key must be a string",key,NONCONTINUABLE);
  169.  
  170.   dkey.dsize = strlen(stringof(key)) + 1;
  171.   dkey.dptr = stringof(key);
  172.  
  173.   ptr = &buf[0];
  174.   /* XXX */
  175.   write_obj(stacktop,record,&ptr,reader);
  176.   /* YYY */
  177.   len=ptr-buf;
  178.  
  179.   if (len >= MAXOBJLEN)
  180.     CallError(stacktop,"dbase-store: Overflowed buffer",nil,NONCONTINUABLE);
  181.  
  182.   drecord.dptr = (char *) &buf[0];    
  183.   if (len + dkey.dsize & 1) len ++;
  184.  
  185.   drecord.dsize= len;
  186.  
  187.   if (dbm_store(DBMOF(dbase),
  188.         dkey, drecord, DBM_REPLACE) < 0)
  189.     {    
  190.       perror("store");
  191.       dbm_clearerr( DBMOF( dbase));
  192.       CallError(stacktop,"dbm_store error",nil,NONCONTINUABLE);
  193.     }
  194.  
  195.   return lisptrue;
  196. }
  197. EUFUN_CLOSE
  198.  
  199. EUFUN_2( Fn_dbase_delete, dbase, key)
  200. {
  201.   datum dkey;
  202.  
  203.   if (!is_string(key))
  204.     CallError(stacktop,"dbase_delete: Key must be a string",key,NONCONTINUABLE);
  205.  
  206.   dkey.dptr = stringof(key);
  207.   dkey.dsize = strlen(stringof(key));
  208.   
  209.   if (dbm_delete( DBMOF(dbase),dkey)<0)
  210.     return nil;
  211.   else return lisptrue;
  212. }
  213. EUFUN_CLOSE
  214.  
  215. EUFUN_1( Fn_dbase_close, dbase)
  216. {
  217.   
  218.   dbm_close( DBMOF(dbase));
  219.         
  220.   return lisptrue;
  221. }
  222. EUFUN_CLOSE
  223.  
  224. EUFUN_1( Fn_dbase_firstkey, dbase)
  225. {
  226.   datum key;
  227.  
  228.   key = dbm_firstkey( DBMOF( dbase));
  229.         
  230.   if (key.dptr == NULL) 
  231.     return nil;
  232.   
  233.   *(key.dptr+key.dsize) = '\0';
  234.   return (allocate_string(stacktop,key.dptr,key.dsize));
  235. }
  236. EUFUN_CLOSE
  237.  
  238.  
  239. EUFUN_1( Fn_dbase_nextkey, dbase)
  240. {
  241.   datum key;
  242.  
  243.   key = dbm_nextkey( DBMOF(dbase));
  244.         
  245.   if (key.dptr == NULL) 
  246.     return nil;
  247.   
  248.   *(key.dptr+key.dsize) = '\0';
  249.   return (allocate_string(stacktop,key.dptr,key.dsize));
  250.  
  251. }
  252. EUFUN_CLOSE
  253.  
  254. EUFUN_1( Fn_string_hash, string)
  255. {
  256.   extern unsigned long dbm_hash(char *,int);
  257.  
  258.   unsigned long i;
  259.  
  260.   if (!is_string(string))
  261.     CallError(stacktop,"string_hash: not a string",string,NONCONTINUABLE);
  262.  
  263.   i = dbm_hash(stringof(string),strlen(stringof(string)));
  264.   
  265. #ifdef PARANOID
  266.    printf("string: (%d)[%s] hash: %d\n",
  267.      strlen(string->STRING.value),
  268.      string->STRING.value,
  269.      i); 
  270. #endif
  271.                                    
  272.   return allocate_integer(stacktop,abs(i));
  273. }
  274. EUFUN_CLOSE
  275.  
  276. EUFUN_2( Md_db_generic_prin, db,  str)
  277. {
  278.   char buf[50];
  279.   if (!is_stream(str))
  280.     CallError(stacktop,"generic-prin: bad stream",str,NONCONTINUABLE);
  281.   
  282.   sprintf(buf,"#<Database %x>",(int)DBMOF(db));
  283.   print_string(stacktop,str,buf);
  284.   
  285.   return(db);
  286. }
  287. EUFUN_CLOSE
  288.  
  289. static EUFUN_0( Fn_dbase_info)
  290. {
  291. #ifdef __FILE__
  292.   printf("%s compiled: %s\n", __FILE__,MAKE_DATE);
  293. #else
  294.   syntax error
  295. #endif
  296.   return nil;
  297. }
  298. EUFUN_CLOSE
  299.  
  300. #define DBM_ENTRIES (12)
  301. MODULE Module_dbm;
  302. LispObject Module_dbm_values[DBM_ENTRIES];
  303.  
  304. void INIT_database(LispObject *stacktop)
  305. {
  306.   extern LispObject generic_generic_prin;
  307.   extern LispObject get_symbol(LispObject *,char *);
  308.  
  309.  
  310.   EUDEBUG(fprintf(stderr,"Version Date: %s\n", MAKE_DATE));
  311.  
  312.   sym_name = get_symbol(stacktop,"name");
  313.   add_root(&sym_name);
  314.   sym_mode = get_symbol(stacktop,"mode");
  315.   add_root(&sym_mode);
  316.   sym_readonly = get_symbol(stacktop,"readonly");
  317.   add_root(&sym_readonly);
  318.   sym_readwrite = get_symbol(stacktop,"read-write");
  319.   add_root(&sym_readwrite);
  320.   sym_create = get_symbol(stacktop,"create");
  321.   add_root(&sym_create);
  322.  
  323.   open_module(stacktop,&Module_dbm,Module_dbm_values,
  324.           "dbm",DBM_ENTRIES);
  325.  
  326.   (void) make_module_function(stacktop,"dbase-open",Fn_open_dbase,-1);
  327.   (void) make_module_function(stacktop,"dbase-fetch",Fn_dbase_fetch,-3);
  328.   (void) make_module_function(stacktop,"dbase-store",Fn_dbase_store,-4);
  329.   (void) make_module_function(stacktop,"dbase-delete",Fn_dbase_delete,2);
  330.   (void) make_module_function(stacktop,"dbase-close",Fn_dbase_close,1);
  331.   (void) make_module_function(stacktop,"dbase-firstkey",Fn_dbase_firstkey,1);
  332.   (void) make_module_function(stacktop,"dbase-nextkey",Fn_dbase_nextkey,1);
  333.   (void) make_module_function(stacktop,"dbm-info",Fn_dbase_info,0);
  334.   (void) make_module_function(stacktop,"string-hash",Fn_string_hash,1);
  335.   /* We don't install methods on generic-dbase-store, etc */
  336.   generic_dbase_store
  337.     = make_wrapped_module_generic(stacktop,"generic-dbase-store",3,Gf_generic_dbase_store);
  338.  
  339.   generic_dbase_fetch
  340.     = make_wrapped_module_generic(stacktop,"generic-dbase-fetch",2,Gf_generic_dbase_fetch);
  341.  
  342.   make_module_function(stacktop,"Md_generic_prin_Database",
  343.                Md_db_generic_prin,2);
  344.  
  345.   close_module();
  346. }
  347.  
  348.  
  349.